unit structure;

interface

uses classes,sysutils,vm;

procedure structurewords(vm:TKsanaForthVM);

procedure forth_branch(vm:TKsanaForthVM);
procedure forth_0branch(vm:TKsanaForthVM);

procedure forth_doif(vm:TKsanaForthVM);
procedure forth_doelse(vm:TKsanaForthVM);
procedure forth_dothen(vm:TKsanaForthVM);
procedure forth_dofor(vm:TksanaforthVM);
procedure forth_donext(vm:TksanaforthVM);
procedure forth_if(vm:TKsanaForthVM);
procedure forth_else(vm:TKsanaForthVM);
procedure forth_then(vm:TKsanaForthVM);

implementation

// branch to token list addr given in next cell if poped value is 0
procedure forth_0branch(vm:TKsanaForthVM);
begin if vm.pop=0 then
           forth_branch(vm)
      else inc(vm.ip,CELLSIZE);
end;
// branch to token list addr given in next cell
procedure forth_branch(vm:TKsanaForthVM);
begin vm.ip:=pinteger(vm.ip)^;
end;

// branch to token list addr given in next cell if poped value is 0
procedure forth_doif(vm:TKsanaForthVM);
begin if vm.pop=0 then
           forth_branch(vm)
      else inc(vm.ip,CELLSIZE);
end;
// branch to token list addr given in next cell
procedure forth_doelse(vm:TKsanaForthVM);
begin vm.ip:=pinteger(vm.ip)^;
end;
// no opration, working as a target flag
procedure forth_dothen(vm:TKsanaForthVM);
begin
end;
// no opration, working as a target flag
procedure forth_dobegin(vm:TKsanaForthVM);
begin
end;
// branch to token list addr given in next cell
procedure forth_doagain(vm:TKsanaForthVM);
begin vm.ip:=pinteger(vm.ip)^;
end;
// branch to token list addr given in next cell if poped value is 0
procedure forth_dountil(vm:TKsanaForthVM);
begin if vm.pop=0 then
           forth_branch(vm)
      else inc(vm.ip,CELLSIZE);
end;
// branch to token list addr given in next cell if poped value is 0
procedure forth_dowhile(vm:TKsanaForthVM);
begin if vm.pop=0 then
           forth_branch(vm)
      else inc(vm.ip,CELLSIZE);
end;
// branch to token list addr given in next cell
procedure forth_dorepeat(vm:TKsanaForthVM);
begin vm.ip:=pinteger(vm.ip)^;
end;
//
procedure forth_begin(vm:TKsanaForthVM);
begin
  vm.compilecode(integer(@forth_dobegin));//or COMPILEONLY_MASK);
  vm.push(vm.cp);
end;
procedure forth_again(vm:TKsanaForthVM);
begin if vm.interpreting then exit;
      vm.compilecode(integer(@forth_doagain));//or COMPILEONLY_MASK);
      vm.compilecell(vm.pop); // going to the place after begin
end;
procedure forth_until(vm:TKsanaForthVM);
begin if vm.interpreting then exit;
      vm.compilecode(integer(@forth_dountil));//or COMPILEONLY_MASK);
      vm.compilecell(vm.pop); // going to the place after begin
end;
procedure forth_while(vm:TKsanaForthVM);
begin if vm.interpreting then exit;
      vm.compilecode(integer(@forth_dowhile));//or COMPILEONLY_MASK);
      vm.push(vm.cp);
      vm.compilecell(-1); // for going to the place after repeat
      vm.swap;
end;
procedure forth_repeat(vm:TKsanaForthVM);
begin if vm.interpreting then exit;
      vm.compilecode(integer(@forth_dorepeat));//or COMPILEONLY_MASK);
      vm.compilecell(vm.pop); // going to the place after begin
      pinteger(vm.pop)^:=vm.cp; // coming to here from while 
end;
procedure forth_if(vm:TKsanaForthVM);
begin if vm.interpreting then exit;
      vm.compilecode(integer(@forth_doif));//or COMPILEONLY_MASK);
      vm.push(vm.cp);
      vm.compilecell(-1); // place holder
end;
procedure forth_else(vm:TKsanaForthVM);
var jmp:integer;
begin if vm.interpreting then exit;
      jmp:=vm.pop;
      vm.compilecode(integer(@forth_doelse));//or COMPILEONLY_MASK);
      vm.push(vm.cp);
      vm.compilecell($EEEEEEEE);
      pinteger(jmp)^:=vm.cp;
end;
procedure forth_then(vm:TKsanaForthVM);
begin if vm.interpreting then exit;
      vm.compilecode(integer(@forth_dothen));//or COMPILEONLY_MASK);
      pinteger(vm.pop)^:=vm.cp;
end;
// runtime 'for'
procedure forth_dofor(vm:TksanaforthVM);
begin vm.rpush(vm.pop); // push loop count to return stack
end;
// branch to token list addr given in next cell
procedure forth_doaft(vm:TKsanaForthVM);
begin vm.ip:=pinteger(vm.ip)^;
end;
// runtime 'next'
procedure forth_donext(vm:TKsanaForthVM);
begin vm.rtos:=vm.rtos-1;
     if vm.rtos<0 then begin
         vm.rpop; inc(vm.ip,CELLSIZE) // exit loop to next cell
     end else begin
         vm.ip:=pinteger(vm.ip)^;     // loop back
     end;
end;
// compile 'for'
procedure forth_for(vm:TKsanaForthVM);
begin
  if vm.interpreting then exit;
  vm.compilecode(integer(@forth_dofor));//or COMPILEONLY_MASK);
  vm.push(vm.cp);  //push cp to tos
end;
procedure forth_aft(vm:TKsanaForthVM);
begin if vm.interpreting then exit;
      vm.tos:=vm.cp+8;
      vm.compilecode(integer(@forth_doaft));//or COMPILEONLY_MASK);
      vm.push(vm.cp);
      vm.compilecell($AFAFAFAF); // place holder
end;
// compile 'next'
procedure forth_next(vm:TKsanaForthVM);
begin
  if vm.interpreting then exit;
  if integer(pointer(vm.tos)^)=integer($AFAFAFAF) then
      pinteger(vm.pop)^:=vm.cp;
  vm.compilecode(integer(@forth_donext));//or COMPILEONLY_MASK);
  vm.compilecell(vm.pop); // CP is pushed by forth_for, compile to next cell
end;

procedure forth_dodo(vm:TKsanaForthVM);
var start,limit:integer;
begin
  start:=vm.pop; limit:=vm.pop;
  vm.rpush(pinteger(vm.ip)^); inc(vm.ip,sizeof(integer));
  vm.rpush(limit); vm.rpush(start);
end;

procedure forth_doqdo(vm:TKsanaForthVM);
var start,limit:integer;
begin
  start:=vm.pop; limit:=vm.pop;
  if start=limit then begin
    vm.ip:=pinteger(vm.ip)^; exit;
  end;
  vm.rpush(pinteger(vm.ip)^); inc(vm.ip,sizeof(integer));
  vm.rpush(limit); vm.rpush(start);
end;

procedure doloop(vm:TKsanaForthVM;delta:integer);
begin
  if delta>0 then begin
    vm.rtos:=vm.rtos+delta;
    if vm.rtos>=vm.rsec then begin
      vm.rpop; vm.rpop; vm.rpop;
      inc(vm.ip,sizeof(integer));
    end else begin
      vm.ip:=pinteger(vm.ip)^;
    end;
  end else begin
    if vm.rtos<=vm.rsec then begin
      vm.rpop; vm.rpop; vm.rpop;
      inc(vm.ip,sizeof(integer));
    end else begin
      vm.rtos:=vm.rtos+delta;
      vm.ip:=pinteger(vm.ip)^;
    end;
  end;
end;

procedure forth_doloop(vm:TKsanaForthVM);
begin doloop(vm,1);
end;

procedure forth_doploop(vm:TKsanaForthVM);
begin doloop(vm,vm.pop);
end;

procedure forth_do(vm:TKsanaForthVM);
begin
  vm.compilecode(integer(@forth_dodo));//or COMPILEONLY_MASK);
  vm.push(vm.cp);
  vm.compilecell($DDDDDDDD); // CP is pushed by forth_do, compile to next cell
end;

procedure forth_qdo(vm:TKsanaForthVM);
begin
  vm.compilecode(integer(@forth_doqdo));//or COMPILEONLY_MASK);
  vm.push(vm.cp);
  vm.compilecell($DDDDDDDD); // CP is pushed by forth_do, compile to next cell
end;

procedure forth_i(vm:TKsanaForthVM);
begin vm.push(vm.rtos);
end;

procedure forth_j(vm:TKsanaForthVM);
begin vm.push(vm.rstack[(vm.rp-3)and $FF]);
end;

procedure forth_k(vm:TKsanaForthVM);
begin vm.push(vm.rstack[(vm.rp-6)and $FF]);
end;

procedure forth_ip(vm:TKsanaForthVM);
begin vm.push(vm.rsec);
end;

procedure forth_jp(vm:TKsanaForthVM);
begin vm.push(vm.rstack[(vm.rp-4)and $FF]);
end;

procedure forth_kp(vm:TKsanaForthVM);
begin vm.push(vm.rstack[(vm.rp-7)and $FF]);
end;

procedure forth_idp(vm:TKsanaForthVM);
begin vm.push(vm.rstack[(vm.rp-2)and $FF]);
end;

procedure forth_jdp(vm:TKsanaForthVM);
begin vm.push(vm.rstack[(vm.rp-5)and $FF]);
end;

procedure forth_kdp(vm:TKsanaForthVM);
begin vm.push(vm.rstack[(vm.rp-8)and $FF]);
end;

procedure forth_loop(vm:TKsanaForthVM);
begin
  vm.compilecode(integer(@forth_doloop));//or COMPILEONLY_MASK);
  vm.compilecell(vm.tos+sizeof(integer)); // CP is pushed by forth_for, compile to next cell
  pinteger(vm.pop)^:=vm.cp;
end;

procedure forth_ploop(vm:TKsanaForthVM);
begin
  vm.compilecode(integer(@forth_doploop));//or COMPILEONLY_MASK);
  vm.compilecell(vm.tos+sizeof(integer)); // CP is pushed by forth_for, compile to next cell
  pinteger(vm.pop)^:=vm.cp;
end;

procedure structurewords(vm:TKsanaForthVM);
begin
//vm.addcodeword('0branch',integer(@forth_0branch  ),false,true); //// ( f -- )
//vm.addcodeword('branch' ,integer(@forth_branch   ),false,true); //// ( -- )

  vm.addcodeword('(if)'    ,integer(@forth_doif    ),false,true); //// ( f -- )
  vm.addcodeword('(else)'  ,integer(@forth_doelse  ),false,true); //// ( -- )
  vm.addcodeword('(then)'  ,integer(@forth_dothen  ),false,true); //// ( -- )
  vm.addcodeword('(begin)' ,integer(@forth_dobegin ),false,true); //// ( -- )
  vm.addcodeword('(again)' ,integer(@forth_doagain ),false,true); //// ( -- )
  vm.addcodeword('(until)' ,integer(@forth_dountil ),false,true); //// ( f -- )
  vm.addcodeword('(while)' ,integer(@forth_dowhile ),false,true); //// ( f -- )
  vm.addcodeword('(repeat)',integer(@forth_dorepeat),false,true); //// ( -- )
  vm.addcodeword('(for)'   ,integer(@forth_dofor   ),false,true); //// ( n -- )
  vm.addcodeword('(aft)'   ,integer(@forth_doaft   ),false,true); //// ( -- )
  vm.addcodeword('(next)'  ,integer(@forth_donext  ),false,true); //// ( -- )
  vm.addcodeword('(do)'    ,integer(@forth_dodo    ),false,true); //// ( lmt bgn -- )
  vm.addcodeword('(?do)'   ,integer(@forth_doqdo   ),false,true); //// ( lmt bgn -- )
  vm.addcodeword('(loop)'  ,integer(@forth_doloop  ),false,true); //// ( -- )
  vm.addcodeword('(+loop)' ,integer(@forth_doploop ),false,true); //// ( n -- )

  vm.addcodeword('if'    ,integer(@forth_if    ),true,true); //// ( -- ai )
  vm.addcodeword('else'  ,integer(@forth_else  ),true,true); //// ( ai-- ae )
  vm.addcodeword('then'  ,integer(@forth_then  ),true,true); //// ( a -- )
  vm.addcodeword('for'   ,integer(@forth_for   ),true,true); //// ( -- af )
  vm.addcodeword('aft'   ,integer(@forth_aft   ),true,true); //// ( af -- aa )
  vm.addcodeword('next'  ,integer(@forth_next  ),true,true); //// ( a -- )
  vm.addcodeword('do'    ,integer(@forth_do    ),true,true); //// ( -- ad )
  vm.addcodeword('?do'   ,integer(@forth_qdo   ),true,true); //// ( -- ad )
  vm.addcodeword('i'     ,integer(@forth_i     )          ); //// ( -- i ) level 0 loop index
  vm.addcodeword('j'     ,integer(@forth_j     )          ); //// ( -- j ) level 1 loop index
  vm.addcodeword('k'     ,integer(@forth_k     )          ); //// ( -- k ) level 2 loop index
  vm.addcodeword('i'''   ,integer(@forth_ip    )          ); //// ( -- i' ) level 0 loop limit
  vm.addcodeword('j'''   ,integer(@forth_jp    )          ); //// ( -- j' ) level 1 loop limit
  vm.addcodeword('k'''   ,integer(@forth_kp    )          ); //// ( -- k' ) level 2 loop limit
  vm.addcodeword('i"'    ,integer(@forth_idp   )          ); //// ( -- i" ) level 0 loop leave
  vm.addcodeword('j"'    ,integer(@forth_jdp   )          ); //// ( -- j" ) level 1 loop leave
  vm.addcodeword('k"'    ,integer(@forth_kdp   )          ); //// ( -- k" ) level 2 loop leave
  vm.addcodeword('loop'  ,integer(@forth_loop  ),true,true); //// ( ad -- )
  vm.addcodeword('+loop' ,integer(@forth_ploop ),true,true); //// ( ad -- )
  vm.addcodeword('begin' ,integer(@forth_begin ),true,true); //// ( -- ab )
  vm.addcodeword('again' ,integer(@forth_again ),true,true); //// ( ab -- )
  vm.addcodeword('until' ,integer(@forth_until ),true,true); //// ( ab -- )
  vm.addcodeword('while' ,integer(@forth_while ),true,true); //// ( ab -- aw )
  vm.addcodeword('repeat',integer(@forth_repeat),true,true); //// ( aw -- )
  //do loop
end;

end.
